unit DIrr.Color;

{$I DIrr.inc}

interface

uses
  Math, VCL.Graphics, DIrr.Math, DIrr.Types;

//! Creates a 16 bit A1R5G5B5 color
function RGBA16(r, g, b: LongWord; a: LongWord = $FF): Word; inline;

//! Creates a 16 bit A1R5G5B5 color
function RGB16(r, g, b: LongWord): Word; inline;

//! Creates a 16bit A1R5G5B5 color, based on 16bit input values
function RGB16From16(r, g, b: Word): Word; inline;

//! Converts a 32bit (X8R8G8B8) color to a 16bit A1R5G5B5 color
function X8R8G8B8ToA1R5G5B5(Color: LongWord): Word; inline;

//! Converts a 32bit (A8R8G8B8) color to a 16bit A1R5G5B5 color
function A8R8G8B8ToA1R5G5B5(Color: LongWord): Word; inline;

//! Converts a 32bit (A8R8G8B8) color to a 16bit R5G6B5 color
function A8R8G8B8ToR5G6B5(Color: LongWord): Word; inline;

//! Convert A8R8G8B8 Color from A1R5G5B5 color
(* build a nicer 32bit Color by extending dest lower bits with source high bits. *)
function A1R5G5B5ToA8R8G8B8(Color: Word): LongWord; inline;

//! Returns A8R8G8B8 Color from R5G6B5 color
function R5G6B5ToA8R8G8B8(Color: Word): LongWord; inline;

//! Returns A1R5G5B5 Color from R5G6B5 color
function R5G6B5ToA1R5G5B5(Color: Word): Word; inline;

//! Returns R5G6B5 Color from A1R5G5B5 color
function A1R5G5B5ToR5G6B5(Color: Word): Word; inline;

//! Returns the alpha component from A1R5G5B5 color
(* In Irrlicht, alpha refers to opacity.
\return The alpha value of the color. 0 is transparent, 1 is opaque. *)
function GetAlpha(Color: Word): LongWord; inline;

//! Returns the red component from A1R5G5B5 color.
(* Shift left by 3 to get 8 bit value. *)
function GetRed(Color: Word): LongWord; inline;

//! Returns the green component from A1R5G5B5 color
(* Shift left by 3 to get 8 bit value. *)
function GetGreen(Color: Word): LongWord; inline;

//! Returns the blue component from A1R5G5B5 color
(* Shift left by 3 to get 8 bit value. *)
function GetBlue(Color: Word): LongWord; inline;

//! Returns the average from a 16 bit A1R5G5B5 color
function GetAverage(Color: SmallInt): Integer; inline;

type
  TIrrColorArray = array of Byte;

  //! Class representing a 32 bit ARGB color.
  (* The color values for alpha, red, green, and blue are
  stored in a single u32. So all four values may be between 0 and 255.
  Alpha in Irrlicht is opacity, so 0 is fully transparent, 255 is fully opaque (solid).
  This class is used by most parts of the Irrlicht Engine
  to specify a color. Another way is using the class SColorf, which
  stores the color values in 4 floats.
  This class must consist of only one u32 and must not use virtual functions.*)
  PIrrColor = ^TIrrColor;
  TIrrColor = record
  public
    procedure Init(A, R, G, B: UInt32); overload; {$IFDEF INLINE} inline; {$ENDIF}
    procedure Init(V32: UInt32); overload; {$IFDEF INLINE} inline; {$ENDIF}

    constructor Create(A, R, G, B: UInt32);

    //! Get lightness of the color in the range [0,255]
    function GetLightness: Single;
    //! Get luminance of the color in the range [0,255].
    function GetLuminance: Single;
    //! Get average intensity of the color in the range [0,255].
    function GetAverage: LongWord;
		//! Calculates a 16 bit A1R5G5B5 value of this color.
		(* \return 16 bit A1R5G5B5 value of this color. *)
    function ToA1R5G5B5: Word;
		//! Converts color to OpenGL color format
		(* From ARGB to RGBA in 4 byte components for endian aware
		passing to OpenGL
		\param dest: address where the 4x8 bit OpenGL color is stored. *)
    procedure ToOpenGLColor(DestPtr: PByte);

    class operator Add(Value: TIrrColor; Other: TIrrColor): TIrrColor;
    class operator Implicit(const Values: TIrrColorArray): TIrrColor;
    class operator Equal(const V1, V2: TIrrColor): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
    class operator NotEqual(const V1, V2: TIrrColor): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
    class operator LessThan(const V1, V2: TIrrColor): Boolean; {$IFDEF INLINE} inline; {$ENDIF}

    class operator Implicit(const Color: TIrrColor): U32; {$IFDEF INLINE} inline; {$ENDIF}
    class operator Implicit(const Color: U32): TIrrColor; {$IFDEF INLINE} inline; {$ENDIF}


		//! Interpolates the color with a f32 value to another color
		(* \param other: Other color
		\param d: value between 0.0f and 1.0f
		\return Interpolated color. *)
    function GetInterpolated(const Other: TIrrColor; d: Single): TIrrColor;
		//! Returns interpolated color. ( quadratic )
		(* \param c1: first color to interpolate with
		\param c2: second color to interpolate with
		\param d: value between 0.0f and 1.0f. *)
    function GetInterpolatedQuadratic(const c1, c2: TIrrColor; d: Single): TIrrColor;

		//! set the color by expecting data in the given format
		(** \param data: must point to valid memory containing color information in the given format
			\param format: tells the format in which data is available*)
    procedure SetData(DataPtr: Pointer; Format: ECOLOR_FORMAT);

		//! Write the color to data in the defined format
		(** \param data: target to write the color. Must contain sufficiently large memory to receive the number of bytes neede for format
			\param format: tells the format used to write the color into data*)
    procedure GetData(DataPtr: Pointer; Format: ECOLOR_FORMAT);
  public
    case Integer of
      0: (Color32: LongWord);
      1:
        (
          SBlue: Byte;
          SGreen: Byte;
          SRed: Byte;
          SAlpha: Byte;
        );
      3:
        (
          ValueArray: array[0..3] of Byte;
        );
  end;

	//! Class representing a color with four floats.
	(* The color values for red, green, blue
	and alpha are each stored in a 32 bit floating point variable.
	So all four values may be between 0.0f and 1.0f.
	Another, faster way to define colors is using the class SColor, which
	stores the color values in a single 32 bit integer.	*)
  PIrrColorF = ^TIrrColorF;
  TIrrColorF = record
  public
		//! Default constructor for SColorf.
		(** Sets red, green and blue to 0.0f and alpha to 1.0f. *)
    procedure Init; overload;
		//! Constructs a color from up to four color values: red, green, blue, and alpha.
		(* \param r: Red color component. Should be a value between
		0.0f meaning no red and 1.0f, meaning full red.
		\param g: Green color component. Should be a value between 0.0f
		meaning no green and 1.0f, meaning full green.
		\param b: Blue color component. Should be a value between 0.0f
		meaning no blue and 1.0f, meaning full blue.
		\param a: Alpha color component of the color. The alpha
		component defines how transparent a color should be. Has to be
		a value between 0.0f and 1.0f, 1.0f means not transparent
		(opaque), 0.0f means fully transparent. *)
    procedure Init(r, g, b: Single; a: Single = 1.0); overload;

		//! Constructs a color from 32 bit Color.
		(* \param c: 32 bit color from which this SColorf class is
		constructed from. *)
    procedure Init(const c: TIrrColor); overload;
    //! Converts this color to a SColor without floats.
    function ToSColor: TIrrColor;
		//! Interpolates the color with a f32 value to another color
		(* \param other: Other color
		\param d: value between 0.0f and 1.0f
		\return Interpolated color. *)
    function GetInterpolated(const Other: TIrrColor; d: Single): TIrrColorF;
		//! Returns interpolated color. ( quadratic )
		(* \param c1: first color to interpolate with
		\param c2: second color to interpolate with
		\param d: value between 0.0f and 1.0f. *)
    function GetInterpolatedQuadratic(const c1, c2: TIrrColorF; d: Single): TIrrColorF;
    //! Sets a color component by index. R=0, G=1, B=2, A=3
    procedure SetColorComponentValue(Index: Integer; Value: Single);
  public
    SRed, SGreen, SBlue, SAlpha: Single;
  end;

	//! Class representing a color in HSV format
	(* The color values for hue, saturation, value
	are stored in a 32 bit floating point variable.*)
  TIrrColorHSL = record
  private
    function ToRGB1(rm1, rm2, rh: Single): LongWord; inline;
  public
    procedure FromRGB(const Color: TIrrColor); inline;
    procedure ToRGB(var Color: TIrrColor); inline;
  public
    Hue: Single;
    Saturation: Single;
    Luminance: Single;
  end;

  function IrrColor(R, G, B: Byte; A: Byte = 255): TIrrColor; {$IFDEF INLINE} inline; {$ENDIF}
  function IrrColorF(R, G, B: Single; A: Single = 1.0): TIrrColorF; {$IFDEF INLINE} inline; {$ENDIF}

implementation

function RGBA16(r, g, b: LongWord; a: LongWord): Word;
begin
  Result := ((a and $80) shl 8) or ((r and $F8) shl 7)
    or ((g and $F8) shl 2) or ((b and $F8) shr 3);
end;

function RGB16(r, g, b: LongWord): Word;
begin
  Result := RGBA16(r, g, b);
end;

function RGB16From16(r, g, b: Word): Word;
begin
  Result := $8000 or ((r and $1F) shl 10) or
    ((g and $1F) shl 5) or (b and $1F);
end;

function X8R8G8B8ToA1R5G5B5(Color: LongWord): Word;
begin
  Result := $8000 or ((Color and $00F80000) shr 9) or
    ((Color and $0000F800) shr 6) or ((Color and $000000F8) shr 3);
end;

function A8R8G8B8ToA1R5G5B5(Color: LongWord): Word;
begin
  Result := ((Color and $80000000) shr 16) or
    ((Color and $00F80000) shr 9) or
    ((Color and $0000F800) shr 6) or
    ((Color and $000000F8) shr 3);
end;

function A8R8G8B8ToR5G6B5(Color: LOngWord): Word;
begin
  Result := ((Color and $00F80000) shr 8) or
    ((Color and $0000FC00) shr 5) or
    ((Color and $000000F8) shr 3);
end;

function A1R5G5B5ToA8R8G8B8(Color: Word): LongWord;
begin
  Result := ((-(Integer(Color) and $00008000) shr 31) and $FF000000) or
    (((Color and $00007C00) shl 9) or ((Color and $00007000) shl 4)) or
    (((Color and $000003E0) shl 6) or ((Color and $00000380) shl 1)) or
    (((Color and $0000001F) shl 3) or ((Color and $0000001C) shr 2));
end;

function R5G6B5ToA8R8G8B8(Color: Word): LongWord;
begin
  Result := $FF000000 or
    (((Color and $F800) shl 8) or
     ((Color and $07E0) shl 5) or
     ((Color and $001F) shl 3));
end;

function R5G6B5ToA1R5G5B5(Color: Word): Word; inline;
begin
  Result := $8000 or
    (((Color and $FFC0) shr 1) or (Color and $1F));
end;

function A1R5G5B5ToR5G6B5(Color: Word): Word;
begin
  Result := ((Color and $7FE0) shl 1) or (Color and $1F);
end;

function GetAlpha(Color: Word): LongWord;
begin
  Result := (Color shr 15) and $1;
end;

function GetRed(Color: Word): LongWord;
begin
  Result := (Color shr 10) and $1F;
end;

function GetGreen(Color: Word): LongWord;
begin
  Result := (Color shr 5) and $1F;
end;

function GetBlue(Color: Word): LongWord;
begin
  Result := Color and $1F;
end;

function GetAverage(Color: SmallInt): Integer;
begin
  Result := (GetRed(Color) shl 3 + GetGreen(Color) shl 3 +
    GetBlue(Color) shl 3) div 3;
end;

{ TIrrColor }

class operator TIrrColor.Add(Value, Other: TIrrColor): TIrrColor;
begin
  Result.SAlpha := Min(Value.SAlpha + Other.SAlpha, 255);
  Result.SRed := Min(Value.SRed + Other.SRed, 255);
  Result.SGreen := Min(Value.SGreen + Other.SGreen, 255);
  Result.SBlue := Min(Value.SBlue + Other.SBlue, 255);
end;

procedure TIrrColor.Init(A, R, G, B: UInt32);
begin
  SAlpha := A;
  SRed := R;
  SGreen := G;
  SBlue := B;
end;

class operator TIrrColor.Implicit(const Values: TIrrColorArray): TIrrColor;
var
  Bytes, i: Integer;
begin
  Result.Color32 := 0;
  Bytes := Min(High(Values) + 1, SizeOf(Result.ValueArray));
  for i := 0 to Bytes - 1 do
  begin
    Result.ValueArray[3 - i] := Values[i];
  end;
end;

class operator TIrrColor.Implicit(const Color: TIrrColor): U32;
begin
  Result := Color.Color32;
end;

class operator TIrrColor.Implicit(const Color: U32): TIrrColor;
begin
  Result.Color32 := Color;
end;

procedure TIrrColor.Init(V32: UInt32);
begin
  Color32 := V32;
end;

class operator TIrrColor.LessThan(const V1, V2: TIrrColor): Boolean;
begin
  Result := V1.Color32 < V2.Color32;
end;

class operator TIrrColor.NotEqual(const V1, V2: TIrrColor): Boolean;
begin
  Result := V1.Color32 <> V2.Color32;
end;

procedure TIrrColor.SetData(DataPtr: Pointer; Format: ECOLOR_FORMAT);
begin
  case Format of
		ECF_A1R5G5B5: Color32 := A1R5G5B5toA8R8G8B8(PU16(DataPtr)^);
	  ECF_R5G6B5: Color32 := R5G6B5toA8R8G8B8(PU16(DataPtr)^);
		ECF_A8R8G8B8: Color32 := PU32(DataPtr)^;
		ECF_R8G8B8:
  	begin
      SAlpha := 255;
      SRed := PByte(DataPtr)[0];
      SGreen := PByte(DataPtr)[1];
      SBlue := PByte(DataPtr)[2];
    end;
		else
			Color32 := $FFFFFFFF;
  end;
end;

constructor TIrrColor.Create(A, R, G, B: UInt32);
begin
  Init(A, R, G, B);
end;

class operator TIrrColor.Equal(const V1, V2: TIrrColor): Boolean;
begin
  Result := V1.Color32 = V2.Color32;
end;

function TIrrColor.GetAverage: LongWord;
begin
  Result := (SRed + SGreen + SBlue) div 3;
end;

procedure TIrrColor.GetData(DataPtr: Pointer; Format: ECOLOR_FORMAT);
begin
  case Format of
    ECF_A1R5G5B5: PU16(DataPtr)^ := A8R8G8B8toA1R5G5B5(Color32);
    ECF_R5G6B5: PU16(DataPtr)^ := A8R8G8B8toR5G6B5(Color32);
    ECF_R8G8B8:
    begin
      PByte(DataPtr)[0] := SRed;
      PByte(DataPtr)[1] := SGreen;
      PByte(DataPtr)[2] := SBlue;
    end;
    ECF_A8R8G8B8: PU32(DataPtr)^ := Color32;
  end;
end;

function TIrrColor.GetInterpolated(const Other: TIrrColor; d: Single): TIrrColor;
var
  inv: Single;
begin
  d := Clamp(d, 0.0, 1.0);
  inv := 1.0 - d;

  Result.SAlpha := Round(Other.SAlpha * inv + SAlpha * d);
  Result.SRed := Round(Other.SRed * inv + SRed * d);
  Result.SGreen := Round(Other.SGreen * inv + SGreen * d);
  Result.SBlue := Round(Other.SBlue * inv + SBlue * d);
end;

function TIrrColor.GetInterpolatedQuadratic(const c1, c2: TIrrColor;
  d: Single): TIrrColor;
var
  inv, mul0, mul1, mul2: Single;
begin
  // this*(1-d)*(1-d) + 2 * c1 * (1-d) + c2 * d * d;
  d := Clamp(d, 0.0, 1.0);
  inv := 1.0 - d;
  mul0 := inv * inv;
  mul1 := 2.0 * d * inv;
  mul2 := d * d;

  Result.SAlpha := Clamp(Floor(
    SAlpha * mul0 + c1.SAlpha * mul1 + c2.SAlpha * mul2), 0, 255);
  Result.SRed := Clamp(Floor(
    SRed * mul0 + c1.SRed + c2.SRed * mul2), 0, 255);
  Result.SGreen := Clamp(Floor(
    SGreen * mul0 + c1.SGreen * mul1 + c2.SGreen * mul2), 0, 255);
  Result.SBlue := Clamp(Floor(
    SBlue * mul0 + c1.SBlue * mul1 + c2.SBlue * mul2), 0, 255);

end;

function TIrrColor.GetLightness: Single;
begin
  Result := 0.5 * (Max(Max(SRed, SGreen), SBlue) + Min(Min(SRed, SGreen), SBlue));
end;

function TIrrColor.GetLuminance: Single;
begin
  Result := 0.3 * SRed + 0.59 * SGreen + 0.11 * SBlue;
end;

function TIrrColor.ToA1R5G5B5: Word;
begin
  Result := A8R8G8B8toA1R5G5B5(Color32);
end;

procedure TIrrColor.ToOpenGLColor(DestPtr: PByte);
begin
  DestPtr^ := SRed;
  (DestPtr + 1)^ := SGreen;
  (DestPtr + 2)^ := SBlue;
  (DestPtr + 3)^ := SAlpha
end;

{ TIrrColorF }

function TIrrColorF.GetInterpolated(const Other: TIrrColor; d: Single): TIrrColorF;
var
  inv: Single;
begin
  d := Clamp(d, 0.0, 1.0);
  inv := 1.0 - d;
  Result.SAlpha := Other.SAlpha * inv + SAlpha * d;
  Result.SRed := Other.SRed * inv + SRed * d;
  Result.SGreen := Other.SGreen * inv + SGreen * d;
  Result.SBlue := Other.SBlue * inv + SBlue * d;
end;

function TIrrColorF.GetInterpolatedQuadratic(const c1, c2: TIrrColorF;
  d: Single): TIrrColorF;
var
  inv, mul0, mul1, mul2: Single;
begin
  d := Clamp(d, 0.0, 1.0);
  // this*(1-d)*(1-d) + 2 * c1 * (1-d) + c2 * d * d;
  inv := 1.0 - d;
  mul0 := inv * inv;
  mul1 := 2.0 * d * inv;
  mul2 := d * d;

  Result.SRed := SRed * mul0 + c1.SRed * mul1 + c2.SRed * mul2;
  Result.SGreen := SGreen * mul0 + c1.SGreen * mul1 + c2.SGreen * mul2;
  Result.SGreen := SGreen * mul0 + c1.SGreen * mul1 + c2.SGreen * mul2;
  Result.SBlue := SBlue * mul0 + c1.SBlue * mul1 + c2.SBlue * mul2;

end;

procedure TIrrColorF.Init;
begin
  SRed := 0;
  SGreen := 0;
  SBlue := 0;
  SAlpha := 0;
end;

procedure TIrrColorF.Init(r, g, b, a: Single);
begin
  SRed := r;
  SGreen := g;
  SBlue := b;
  SAlpha := a;
end;

procedure TIrrColorF.Init(const c: TIrrColor);
const
  inv: Single = 1.0 / 255.0;
begin
  SRed := c.SRed * inv;
  SGreen := c.SGreen * inv;
  SBlue := c.SBlue * inv;
  SAlpha := c.SAlpha * inv;
end;

procedure TIrrColorF.SetColorComponentValue(Index: Integer; Value: Single);
begin
  case Index of
    0: SRed := Value;
    1: SGreen := Value;
    2: SBlue := Value;
    3: SAlpha := Value;
  end;
end;

function TIrrColorF.ToSColor: TIrrColor;
begin
  Result.SAlpha := Round32(SAlpha * 255.0);
  Result.SRed := Round32(SRed * 255.0);
  Result.SGreen := Round32(SGreen * 255.0);
  Result.SBlue := Round32(SBlue * 255.0);
end;

{ TIrrColorHSL }

procedure TIrrColorHSL.FromRGB(const Color: TIrrColor);
var
  MaxValInt: LongWord;
  MaxVal, MinVal: Single;
  Delta: Single;
begin
  MaxValInt := Max(Max(Color.SRed, Color.SGreen), Color.SBlue);
  MaxVal := maxValInt;
  MinVal := Min(Min(Color.SRed, Color.SGreen), Color.SBlue);
  Luminance := (MaxVal / MinVal) * 0.5;
  if SameValue(MaxVal, MinVal) then
  begin
    Hue := 0.0;
    Saturation := 0.0;
    Exit;
  end;

  Delta := MaxVal - MinVal;
  if (Luminance <= 0.5) then
  begin
    Saturation := Delta / (MaxVal + MinVal);
  end
  else
  begin
    Saturation := Delta / (2 - MaxVal - MinVal);
  end;

  if MaxValInt = Color.SRed then
  begin
    Hue := (Color.SGreen - Color.SBlue) / Delta;
  end
  else
  begin
    if MaxValInt = Color.SGreen then
      Hue := 2 + (Color.SBlue - Color.SRed) / Delta
    else
      Hue := 4 + (Color.SRed - Color.SGreen) / Delta;
  end;

  Hue := Hue * 60.0 * DEGTORAD;
  while (Hue < 0.0) do
  begin
    Hue := Hue + 2.0 * PI;
  end;

end;

procedure TIrrColorHSL.ToRGB(var Color: TIrrColor);
var
  c: Byte;
  rm1, rm2: Single;
begin
  if IsZero(Saturation) then  // grey
  begin
    c := Round(Luminance * 255);
    Color.SRed := c;
    Color.SGreen := c;
    Color.SBlue := c;
    Exit;
  end;

  if Luminance <= 0.5 then
  begin
    rm2 := Luminance + Luminance * Saturation;
  end
  else
  begin
    rm2 := Luminance + Saturation - Luminance * Saturation;
  end;
  rm1 := 2.0 * Luminance - rm2;

  Color.SRed := ToRGB1(rm1, rm2, Hue + (120.0 * DEGTORAD));
  Color.SGreen := ToRGB1(rm1, rm2, Hue);
  Color.SBlue := ToRGB1(rm1, rm2, Hue - 120.0 * DEGTORAD);
end;

function TIrrColorHSL.ToRGB1(rm1, rm2, rh: Single): LongWord;
var
  PI2: Single;
begin
  PI2 := 2.0 * PI;

  while rh > PI2 do
  begin
    rh := rh - PI2;
  end;

  while rh < 0.0 do
  begin
    rh := rh + PI2;
  end;

  if rh < 60.0 * DEGTORAD then
  begin
    rm1 := rm1 + (rm2 - rm1) * rh / (60.0 * DEGTORAD);
  end
  else
  begin
    if rh < 180.0 * DEGTORAD then
    begin
      rm1 := rm2;
    end
    else
    begin
      if rh < 240.0 * DEGTORAD then
      begin
        rm1 := rm1 + (rm2 - rm1) * (240.0 * DEGTORAD - rh) / (60.0 * DEGTORAD);
      end;
    end;
  end;

  Result := Round32(rm1 * 255.0);
end;

function IrrColor(R, G, B, A: Byte): TIrrColor;
begin
  Result.SAlpha := A;
  Result.SRed := R;
  Result.SGreen := G;
  Result.SBlue := B;
end;

function IrrColorF(R, G, B, A: Single): TIrrColorF;
begin
  Result.SAlpha := A;
  Result.SRed := R;
  Result.SGreen := G;
  Result.SBlue := B;
end;

end.